home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / forth / pfe-0.000 / pfe-0 / pfe-0.9.13 / src / double.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-07-17  |  4.4 KB  |  264 lines
  1. /*
  2.  * This file is part of the portable Forth environment written in ANSI C.
  3.  * Copyright (C) 1995  Dirk Uwe Zoller
  4.  *
  5.  * This library is free software; you can redistribute it and/or
  6.  * modify it under the terms of the GNU Library General Public
  7.  * License as published by the Free Software Foundation; either
  8.  * version 2 of the License, or (at your option) any later version.
  9.  *
  10.  * This library is distributed in the hope that it will be useful,
  11.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  13.  * See the GNU Library General Public License for more details.
  14.  *
  15.  * You should have received a copy of the GNU Library General Public
  16.  * License along with this library; if not, write to the Free
  17.  * Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  *
  19.  * This file is version 0.9.13 of 17-July-95
  20.  * Check for the latest version of this package via anonymous ftp at
  21.  *    roxi.rz.fht-mannheim.de:/pub/languages/forth/pfe-VERSION.tar.gz
  22.  * or    sunsite.unc.edu:/pub/languages/forth/pfe-VERSION.tar.gz
  23.  * or    ftp.cygnus.com:/pub/forth/pfe-VERSION.tar.gz
  24.  *
  25.  * Please direct any comments via internet to
  26.  *    duz@roxi.rz.fht-mannheim.de.
  27.  * Thank You.
  28.  */
  29. /*
  30.  * double.c ---               The Optional Double Number Word Set
  31.  * (duz 16Jul93)
  32.  */
  33.  
  34. #include "forth.h"
  35. #include "support.h"
  36. #include "dblsub.h"
  37. #include "compiler.h"
  38.  
  39. #define DSP    ((dCell *)sp)
  40. #define UDP    ((udCell *)sp)
  41.  
  42. void
  43. two_constant_runtime (void)
  44. {
  45.   *--sp = PFA[1];
  46.   *--sp = PFA[0];
  47. }
  48.  
  49. Code (two_constant)
  50. {
  51.   header (two_constant_runtime, 0);
  52.   COMMA (*sp++);
  53.   COMMA (*sp++);
  54. }
  55.  
  56. code (two_literal_execution)
  57. {
  58.   Cell h;
  59.  
  60.   POP (Cell, ip, h);
  61.   POP (Cell, ip, *--sp);
  62.   *--sp = h;
  63. }
  64.  
  65. Code (two_literal)
  66. {
  67.   if (STATE)
  68.     {
  69.       compile1 ();
  70.       COMMA (DSP->hi);
  71.       COMMA (DSP->lo);
  72.       sp += 2;
  73.     }
  74. }
  75. COMPILES (two_literal, two_literal_execution,
  76.       SKIPS_DCELL, DEFAULT_STYLE);
  77.  
  78. Code (two_variable)
  79. {
  80.   header (create_runtime, 0);
  81.   COMMA (0);
  82.   COMMA (0);
  83. }
  84.  
  85. Code (d_plus)
  86. {
  87.   dadd (&DSP[1], &DSP[0]);
  88.   sp += 2;
  89. }
  90.  
  91. Code (d_minus)
  92. {
  93.   dsub (&DSP[1], &DSP[0]);
  94.   sp += 2;
  95. }
  96.  
  97. code (d_dot)
  98. {
  99.   *--sp = 0;
  100.   d_dot_r_ ();
  101.   space_ ();
  102. }
  103.  
  104. code (d_dot_r)
  105. {
  106.   Cell w = *sp++;
  107.   int sign;
  108.  
  109.   if (*sp < 0)
  110.     sign = 1, dnegate (&DSP[0]);
  111.   else
  112.     sign = 0;
  113.   less_number_sign_ ();
  114.   number_sign_s_ ();
  115.   if (sign)
  116.     hold ('-');
  117.   number_sign_greater_ ();
  118.   spaces (w - *sp);
  119.   type_ ();
  120. }
  121.  
  122. Code (d_zero_less)
  123. {
  124.   sp[1] = FLAG (sp[0] < 0);
  125.   sp++;
  126. }
  127.  
  128. Code (d_zero_equals)
  129. {
  130.   sp[1] = FLAG (sp[0] == 0 && sp[1] == 0);
  131.   sp++;
  132. }
  133.  
  134. Code (d_two_star)
  135. {
  136.   dasl ((dCell *) &sp[0], 1);
  137. }
  138.  
  139. Code (d_two_slash)
  140. {
  141.   dasr ((dCell *) &sp[0], 1);
  142. }
  143.  
  144. Code (d_less_than)
  145. {
  146.   sp[3] = FLAG (dless (&DSP[1], &DSP[0]));
  147.   sp += 3;
  148. }
  149.  
  150. Code (d_to_s)
  151. {
  152.   sp++;
  153. }
  154.  
  155. Code (d_equals)
  156. {
  157.   sp[3] = FLAG (sp[2] == sp[0] && sp[3] == sp[1]);
  158.   sp += 3;
  159. }
  160.  
  161. Code (d_abs)
  162. {
  163.   if (*sp < 0)
  164.     dnegate (&DSP[0]);
  165. }
  166.  
  167. Code (d_max)
  168. {
  169.   if (dless (&DSP[1], &DSP[0]))
  170.     DSP[1] = DSP[0];
  171.   sp += 2;
  172. }
  173.  
  174. Code (d_min)
  175. {
  176.   if (dless (&DSP[0], &DSP[1]))
  177.     DSP[1] = DSP[0];
  178.   sp += 2;
  179. }
  180.  
  181. Code (d_negate)
  182. {
  183.   dnegate (&DSP[0]);
  184. }
  185.  
  186. Code (m_star_slash)
  187. {
  188.   udCell lo, hi;
  189.   Cell p, q;
  190.   udiv_t r1, r2;
  191.   int sign = 0;
  192.  
  193.   if ((q = *sp++) < 0)
  194.     q = -q, sign ^= 1;
  195.   if ((p = *sp++) < 0)
  196.     p = -p, sign ^= 1;
  197.   if (*sp < 0)
  198.     dnegate (&DSP[0]), sign ^= 1;
  199.   hi = ummul (sp[0], p);
  200.   lo = ummul (sp[1], p);
  201.   madd ((dCell *) &hi, lo.hi);
  202.   r1 = umdiv (hi, q);
  203.   lo.hi = r1.rem;
  204.   r2 = umdiv (lo, q);
  205.   sp[0] = r1.quot;
  206.   sp[1] = r2.quot;
  207.   if (sign)
  208.     dnegate (&DSP[0]);
  209. }
  210.  
  211. Code (m_plus)
  212. {
  213.   madd ((dCell *) &sp[1], sp[0]);
  214.   sp++;
  215. }
  216.  
  217. Code (two_rot)
  218. {
  219.   Cell h;
  220.  
  221.   h = sp[4];
  222.   sp[4] = sp[2];
  223.   sp[2] = sp[0];
  224.   sp[0] = h;
  225.   h = sp[5];
  226.   sp[5] = sp[3];
  227.   sp[3] = sp[1];
  228.   sp[1] = h;
  229. }
  230.  
  231. Code (d_u_less)
  232. {
  233.   sp[3] = FLAG (duless (&UDP[1], &UDP[0]));
  234.   sp += 3;
  235. }
  236.  
  237. /* *INDENT-OFF* */
  238. LISTWORDS (double) =
  239. {
  240.   CO ("2CONSTANT",    two_constant),
  241.   CS ("2LITERAL",    two_literal),
  242.   CO ("2VARIABLE",    two_variable),
  243.   CO ("D+",        d_plus),
  244.   CO ("D-",        d_minus),
  245.   CO ("D.",        d_dot),
  246.   CO ("D.R",        d_dot_r),
  247.   CO ("D0<",        d_zero_less),
  248.   CO ("D0=",        d_zero_equals),
  249.   CO ("D2*",        d_two_star),
  250.   CO ("D2/",        d_two_slash),
  251.   CO ("D<",        d_less_than),
  252.   CO ("D=",        d_equals),
  253.   CO ("D>S",        d_to_s),
  254.   CO ("DABS",        d_abs),
  255.   CO ("DMAX",        d_max),
  256.   CO ("DMIN",        d_min),
  257.   CO ("DNEGATE",    d_negate),
  258.   CO ("M*/",        m_star_slash),
  259.   CO ("M+",        m_plus),
  260.   CO ("2ROT",        two_rot),
  261.   CO ("DU<",        d_u_less)
  262. };
  263. COUNTWORDS (double, "Double number + extensions");
  264.